home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / threads.c < prev    next >
C/C++ Source or Header  |  1993-07-12  |  27KB  |  1,095 lines
  1. /* ******************************************************************** */
  2. /* threads.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lightweight processes                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: threads.c,v 2.1 1993/01/19 15:41:22 pab Exp $
  9.  *
  10.  * $Log: threads.c,v $
  11.  * Revision 2.1  1993/01/19  15:41:22  pab
  12.  * New Version
  13.  * SYSV paranoia
  14.  *
  15.  * Revision 1.22.1.1  1993/01/17  18:04:48  pab
  16.  * New Version.
  17.  * Added a volatile, ++paranoia regarding old thread chain
  18.  * reformatted code
  19.  *
  20.  * Revision 1.22  1992/11/26  16:13:18  pab
  21.  * Not much
  22.  *
  23.  * Revision 1.20  1992/08/06  18:15:32  pab
  24.  * init. method -> function
  25.  *
  26.  * Revision 1.19  1992/06/01  13:48:33  pab
  27.  * clipper better fix
  28.  *
  29.  * Revision 1.18  1992/05/28  11:28:47  pab
  30.  * moved initialisation around for compiler
  31.  *
  32.  * Revision 1.17  1992/04/29  12:35:11  pab
  33.  * clipper hack
  34.  *
  35.  * Revision 1.16  1992/03/13  18:10:07  pab
  36.  * SysV fixes (protection around semaphores)
  37.  *
  38.  * Revision 1.15  1992/02/10  12:02:38  pab
  39.  * Debugger addition, plus sysV fix
  40.  *
  41.  * Revision 1.14  1992/02/03  00:38:43  pab
  42.  * pre sysV hack
  43.  *
  44.  * Revision 1.13  1992/01/29  20:10:43  pab
  45.  * fewer exports in Generic version
  46.  *
  47.  * Revision 1.12  1992/01/29  13:51:00  pab
  48.  * sysV fixes
  49.  *
  50.  * Revision 1.11  1992/01/21  22:23:52  pab
  51.  * fixed call to garbage_collect
  52.  *
  53.  * Revision 1.10  1992/01/15  21:23:52  pab
  54.  * Fixed alignment problems; made threads allocate int arrays
  55.  *
  56.  * Revision 1.9  1992/01/09  22:29:10  pab
  57.  * Fixed for low tag ints
  58.  *
  59.  * Revision 1.8  1992/01/07  22:15:37  pab
  60.  * ncc compatable, plus backtrace
  61.  *
  62.  * Revision 1.7  1992/01/07  16:18:35  pab
  63.  * tidy of continuation fns
  64.  *
  65.  * Revision 1.6  1992/01/05  22:48:30  pab
  66.  * Minor bug fixes, plus BSD version
  67.  *
  68.  * Revision 1.5  1991/12/22  15:14:43  pab
  69.  * Xmas revision
  70.  *
  71.  * Revision 1.4  1991/11/15  13:45:47  pab
  72.  * copyalloc rev 0.01
  73.  *
  74.  * Revision 1.3  1991/09/22  19:14:43  pab
  75.  * Fixed obvious bugs
  76.  *
  77.  * Revision 1.2  1991/09/11  12:07:49  pab
  78.  * 11/9/91 First Alpha release of modified system
  79.  *
  80.  * Revision 1.1  1991/08/12  16:50:09  pab
  81.  * Initial revision
  82.  *
  83.  * Revision 1.11  1991/06/17  19:01:05  pab
  84.  * Adjusted set_assoc
  85.  *
  86.  * Revision 1.10  1991/06/17  18:58:28  kjp
  87.  * just in case
  88.  *
  89.  * Revision 1.9  1991/04/16  17:59:57  kjp
  90.  * Tidy.
  91.  *
  92.  * Revision 1.8  1991/03/01  15:50:12  kjp
  93.  * Fixed any machine version.
  94.  *
  95.  * Revision 1.7  1991/02/28  14:14:48  kjp
  96.  * Lots of good stuff.
  97.  *
  98.  * Revision 1.6  1991/02/13  18:26:27  kjp
  99.  * Pass.
  100.  *
  101.  */
  102.  
  103. #define COBUG(x) /* fprintf(stderr,"COBUG:");x;fflush(stderr) */
  104.  
  105. /*
  106.  * Change Log:
  107.  *   Version 1, April 1990
  108.  */
  109.  
  110. #include "defs.h"
  111. #include "structs.h"
  112. #include "funcalls.h"
  113.  
  114. #include "global.h"
  115. #include "error.h"
  116.  
  117. #include "calls.h"
  118. #include "modboot.h"
  119. #include "symboot.h"
  120.  
  121. #include "allocate.h"
  122. #include "modules.h"
  123. #include "threads.h"
  124. #include "class.h"
  125. #include "vectors.h"
  126. #include "garbage.h"
  127. #include "streams.h"
  128.  
  129. extern void free(void*);
  130. extern LispObject Thread_Class;
  131.  
  132. int command_line_x_debug;
  133.  
  134. /* *************************************************************** */
  135. /* Simple functions for all machines                               */
  136. /* *************************************************************** */
  137.  
  138. EUFUN_1( Fn_threadp, obj)
  139. {
  140.   return((is_thread(obj)?lisptrue:nil));
  141. }
  142. EUFUN_CLOSE
  143.  
  144. EUFUN_0( Fn_current_thread)
  145. {
  146.   return(CURRENT_THREAD());
  147. }
  148. EUFUN_CLOSE
  149.  
  150. EUFUN_1( Fn_continuationp, obj)
  151. {
  152.   return (is_continue(obj) ? lisptrue : nil);
  153. }
  154. EUFUN_CLOSE
  155.  
  156. /* *************************************************************** */
  157. /* When machines can actually do stuff                             */
  158. /* *************************************************************** */
  159.  
  160. #ifndef MACHINE_ANY
  161.  
  162. #define SCHEDBUG(x) /* fprintf(scheduler_debug,"%d:",system_scheduler_number); \
  163.                     x ;fflush(scheduler_debug) ;*/ /*while(getchar()!='\n');*/
  164. #define SDS (scheduler_debug)
  165.  
  166. #define SET_STATE(th) \
  167.   (set_continue(stacktop,((th)->THREAD.state)))
  168.  
  169. #define PROCEED(cont,value) \
  170.   stacktop = load_thread(cont->CONTINUE.thread); \
  171.   call_continue(stacktop,cont,value);
  172.  
  173. #define RUN_THREAD(th) \
  174.   PROCEED(((th->THREAD.state)),th->THREAD.args);
  175.  
  176. #define RUN_DISPATCHER(arg) \
  177.   { \
  178.     LispObject th = SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread); \
  179.     PROCEED(((th->THREAD.state)),arg); \
  180.   }
  181.  
  182. #define STACK_FIDDLE (16)
  183.  
  184. #define HOG_THREAD(th)
  185. #define RELEASE_THREAD(th)
  186.  
  187. /* Queue for default scheduling methods... */
  188.  
  189. SYSTEM_GLOBAL(LispObject,list_ready_thread_queue);
  190. SYSTEM_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem);
  191. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,local_dispatcher_thread);
  192. static SYSTEM_GLOBAL(LispObject,current_dispatcher_function);
  193. static SYSTEM_GLOBAL(LispObject,list_dispatcher_threads);
  194.  
  195. /* Stack switch user... */
  196.  
  197. static SYSTEM_THREAD_SPECIFIC_DECLARATION(jmp_buf,rig_escape);
  198. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,rig_thread);
  199.  
  200. /* REMEMBER: within this function, we're on the thread's stacks!!! */
  201.  
  202. void rig_thread_aux()
  203. {
  204.   extern LispObject Fn_apply(LispObject*);
  205.  
  206.   LispObject *stacktop;
  207.   LispObject xx;
  208.   LispObject thread = SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread);
  209.  
  210.   if (!setjmp(thread->THREAD.state->CONTINUE.machine_state))
  211.     longjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape),TRUE);
  212.  
  213.   stacktop = thread->THREAD.state->CONTINUE.gc_stack_pointer;
  214.   STACK_TMP(thread);
  215.   EUCALLSET_2(xx,
  216.           Fn_apply,thread->THREAD.fun,thread->THREAD.args);
  217.   UNSTACK_TMP(thread);
  218.   thread->THREAD.value=xx;
  219.   thread_status(thread) = THREAD_RETURNED;
  220.  
  221.   STACK_TMP(thread);
  222.   SCHEDBUG((fprintf(SDS,"thread returned "),
  223.         EUCALL_2(Fn_print,thread,SchedOut)));
  224.   UNSTACK_TMP(thread);
  225.  
  226.   RUN_DISPATCHER(thread);
  227. }
  228.   
  229. LispObject system_thread_rig(LispObject *stacktop, LispObject thread)
  230. {
  231.   int start; /* address to set sp register to */
  232.   /* Allocate the stacks */
  233.  
  234.   STACK_TMP(thread);
  235.   thread_stack_base(thread)
  236.     = (int *) allocate_stack(stacktop,thread_stack_size(thread)*sizeof(int));
  237.   UNSTACK_TMP(thread);
  238.   STACK_TMP(thread);
  239.   thread_gc_stack_base(thread)
  240.     = (LispObject *) allocate_stack(stacktop,thread_gc_stack_size(thread)*sizeof(int));
  241.   UNSTACK_TMP(thread);
  242.   STACK_TMP(thread);
  243.   thread->THREAD.state->CONTINUE.gc_stack_pointer
  244.     = thread_gc_stack_base(thread);
  245.  
  246.   if (setjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape))) return(thread);
  247.   SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread) = thread;
  248.   
  249.   if (thread_stack_base(thread)==NULL)
  250.     CallError(stacktop,"Rig: Got strange thread\n",thread,NONCONTINUABLE);
  251.  
  252.   /* The ~7 is to align on a nice boundary --- no real point making it a #define */
  253.   start=(int) (thread_stack_base(thread)
  254.                       + thread_stack_size(thread) - STACK_FIDDLE)&(~7);
  255. #ifdef STACK_START_MISALIGNED
  256.   start+=4;
  257. #endif
  258.   stack_switch_and_go(start,
  259.               (int) rig_thread_aux);
  260.  
  261.   return(nil);
  262. }
  263.  
  264. /*
  265.  * Free re-usable resources of unrunnable threads... 
  266.  */
  267.  
  268. void shut_down_thread(LispObject *stacktop,LispObject th)
  269. {
  270.   void deallocate_stack(LispObject *, char *, int);
  271.  
  272.   th->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  273.   STACK_TMP(th);
  274.   deallocate_stack(stacktop,(char *) (thread_stack_base(th)), 
  275.            thread_stack_size(th)*sizeof(int));    
  276.   deallocate_stack(stacktop,(char *) (thread_gc_stack_base(th)),
  277.            thread_gc_stack_size(th)*sizeof(int));    
  278.   UNSTACK_TMP(th);
  279.   thread_stack_base(th) = NULL;
  280.   thread_gc_stack_base(th) = NULL;
  281.  
  282. }
  283.  
  284. /* Simple thread creation... */
  285.  
  286. #define MIN_THREAD_STACK_SIZE (4*1024)
  287. #define GC_STACK_RATIO        (4)
  288.  
  289. static SYSTEM_GLOBAL(LispObject,default_thread_stack_size);
  290.  
  291. EUFUN_0( Fn_default_thread_stack_size)
  292. {
  293.   return(SYSTEM_GLOBAL_VALUE(default_thread_stack_size));
  294. }
  295. EUFUN_CLOSE
  296.  
  297. EUFUN_1( Fn_default_thread_stack_size_setter, size)
  298. {
  299.   int csize;
  300.  
  301.   if (!is_fixnum(size))
  302.     CallError(stacktop,"(setter default-thread-stack-size): non-integer",
  303.           size,NONCONTINUABLE);
  304.  
  305.   csize = intval(size);
  306.  
  307.   if (csize < MIN_THREAD_STACK_SIZE)
  308.     CallError(stacktop,"(setter default-thread-stack-size): too small",
  309.           size,NONCONTINUABLE);
  310.  
  311.   SYSTEM_GLOBAL_VALUE(default_thread_stack_size) = size;
  312.  
  313.   return(size);
  314. }
  315. EUFUN_CLOSE
  316.  
  317. static LispObject Cb_signal_callback;
  318.  
  319. void call_thread_signal(LispObject *stacktop, LispObject thread, int sig)
  320. {
  321.   LispObject i,h;
  322.   STACK_TMP(thread);
  323.   i=allocate_integer(stacktop,sig);
  324.   h=CAR(Cb_signal_callback);
  325.   if (h==nil)    
  326.     CallError(stacktop,"Recieved interupt with no handler",i,NONCONTINUABLE);
  327.   UNSTACK_TMP(thread);
  328.  
  329.   EUCALL_3(apply2,h,thread,i);
  330. }
  331.    
  332. EUFUN_1(Fn_set_sig_handler,fn);
  333. {
  334.   CAR(Cb_signal_callback)=fn;
  335. }
  336. EUFUN_CLOSE
  337.  
  338. EUFUN_2(Fn_make_thread, fun, args)
  339. {
  340.   LispObject thread;
  341.  
  342.   if (!is_cons(args)) {
  343.  
  344.     thread 
  345.       = 
  346.     (LispObject) 
  347.       allocate_thread(stacktop,
  348.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  349.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  350.               0);
  351.   }
  352.   else {
  353.     LispObject size;
  354.     int csize;
  355.  
  356.     if (!is_fixnum((size = CAR(args))))
  357.       CallError(stacktop,"make-thread: invalid size",size,NONCONTINUABLE);
  358.  
  359.     csize = intval(size);
  360.  
  361.     if (csize <= 0)
  362.       CallError(stacktop,"make-thread: negative size",size,NONCONTINUABLE);
  363.  
  364.     if (csize < MIN_THREAD_STACK_SIZE)
  365.       CallError(stacktop,
  366.         "make-thread: size less than minimun",size,NONCONTINUABLE);
  367.  
  368.     thread = (LispObject) allocate_thread(stacktop,ALIGN_SIZE(csize),
  369.                       ALIGN_SIZE(csize/GC_STACK_RATIO),0);
  370.   }
  371.  
  372.   fun = ARG_0(stackbase);
  373.   thread->THREAD.fun = fun;
  374.   thread_status(thread) = THREAD_LIMBO;
  375.  
  376.   return(thread);
  377. }
  378. EUFUN_CLOSE
  379.  
  380. EUFUN_1( Fn_thread_reset, th)
  381. {
  382.   if (!is_thread(th))
  383.     CallError(stacktop,"thread-reset: non thread",th,NONCONTINUABLE);
  384.  
  385.   if (thread_status(th) != THREAD_RETURNED 
  386.        && thread_status(th) != THREAD_ABORTED)
  387.     CallError(stacktop,"thread-reset: thread in use",th,NONCONTINUABLE);
  388.  
  389.   (void) system_thread_rig(stacktop,th);
  390.  
  391.   th = ARG_0(stackbase);
  392.   th->THREAD.value = nil;
  393.   thread_status(th) = THREAD_LIMBO;
  394.  
  395.   return(th);
  396. }
  397. EUFUN_CLOSE
  398.  
  399. LispObject generic_thread_call;
  400.  
  401.  
  402. /* Run on the dispatcher thread... */
  403.  
  404. EUFUN_1( Fn_next_ready_thread, c)
  405. {
  406.   LispObject thread;
  407.  
  408.   /* Peek... */
  409.  
  410.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) return(nil);
  411.  
  412.   /* For real... */
  413.  
  414.   system_open_semaphore(stacktop,
  415.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  416.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) {
  417.     system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  418.     return(nil);
  419.   }
  420.  
  421.   thread = CAR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  422.   SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  423.     = CDR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  424.   CDR(thread->THREAD.thd_queue)=nil;
  425.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  426.  
  427.   return(thread);
  428. }
  429. EUFUN_CLOSE
  430.  
  431. EUFUN_1( Fn_run_ready_thread, th)
  432. {
  433.  
  434. /*
  435.   #ifdef MACHINE_SYSTEMV
  436.   fprintf(stderr,"{R(%x):%x}",system_scheduler_number,(int) th);
  437.   fflush(stderr);
  438.   #endif
  439. */
  440.  
  441.   while (( thread_status((volatile LispObject) th)) != THREAD_READY); /* Hedge */
  442.  
  443.   if (SET_STATE(CURRENT_THREAD())) {
  444.     th=ARG_0(stackbase);
  445.     return(th);
  446.   }
  447.   th=ARG_0(stackbase);
  448.   /* Have we done the stack business yet? */
  449.  
  450.   if (thread_stack_base(th) == NULL) {
  451.     system_thread_rig(stacktop,th);
  452.     th = ARG_0(stackbase);
  453.   }
  454.  
  455.   thread_status(th) = THREAD_RUNNING;
  456.  
  457.   RUN_THREAD(th);
  458.  
  459.   return(nil); /* Dummy */
  460. }
  461. EUFUN_CLOSE
  462.   
  463. #define SCHEDULER_RETRY_COUNT (1024) /* was 48*1024*/
  464.  
  465. EUFUN_0( Fn_dispatch)
  466. {
  467.   LispObject from = nil;
  468.   int tries = 0;
  469.  
  470.  restart:
  471.  
  472.   /*
  473.   if (SET_STATE(CURRENT_THREAD())) {
  474.     from = CURRENT_THREAD()->THREAD.state->CONTINUE.value;
  475.     goto restart;
  476.   }
  477.   */
  478.  
  479.   if (is_thread(from)) {
  480.  
  481.     switch (thread_status(from)) {
  482.  
  483.      case THREAD_RETURNED:
  484.      case THREAD_ABORTED:
  485.  
  486.       (void) shut_down_thread(stacktop,from);
  487.       break;
  488.  
  489.      case THREAD_READY:
  490.  
  491.       {
  492.     LispObject tmp,cell = nil;
  493.     STACK_TMP(from); 
  494.     if (from->THREAD.thd_queue==nil)
  495.       {
  496.         LispObject xx;
  497.         xx=EUCALL_2(Fn_cons,nil,nil);
  498.         UNSTACK_TMP(from);
  499.         STACK_TMP(from);
  500.         from->THREAD.thd_queue=xx;
  501.         fprintf(stderr,"{}");
  502.       }
  503.     system_open_semaphore(stacktop,
  504.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  505.     UNSTACK_TMP(from);
  506.     cell=from->THREAD.thd_queue;
  507.         
  508.     CAR(cell)=from;
  509.     CDR(cell)=nil;
  510.     EUCALLSET_2(tmp,
  511.             Fn_nconc,
  512.             SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),cell);
  513.     SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)=tmp;
  514.     system_close_semaphore(
  515.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  516.     
  517.     break;
  518.       }
  519.  
  520.      default:
  521.  
  522.       break;
  523.     }
  524.  
  525.   }
  526.  
  527.   SCHEDBUG(printf("Setting dispatch state...\n"); fflush(stdout));
  528.  
  529.   SCHEDBUG(printf("Dispatching...\n"); fflush(stdout));
  530.  
  531.   tries = 0;
  532.   while (TRUE) 
  533.     {
  534.  
  535.       while (tries < SCHEDULER_RETRY_COUNT)
  536.     {
  537.       LispObject thread;
  538.  
  539.       EUCALLSET_1(thread, Fn_next_ready_thread, Thread);
  540.       if (is_thread(thread)) {
  541.         EUCALLSET_1(from, Fn_run_ready_thread, thread);
  542.         STACK_TMP(from);
  543.         GC_sync_test();
  544.         UNSTACK_TMP(from);
  545.         goto restart;
  546.       }
  547.  
  548.       GC_sync_test();
  549.  
  550.       ++tries;
  551.     }
  552.  
  553.       system_sleep_until_kicked();
  554.  
  555.       GC_sync_test();
  556.  
  557.       tries = 0;
  558.     }
  559.  
  560.   return(nil);
  561. }
  562. EUFUN_CLOSE
  563.   
  564. EUFUN_2(Fn_thread_start, thread, args)
  565. {
  566.   COBUG(fprintf(stderr,"In thread-start\n"));
  567.  
  568.   if (!is_thread(thread))
  569.     CallError(stacktop,
  570.           "thread-start: non-thread argument",thread,NONCONTINUABLE);
  571.  
  572.   if (thread_status(thread) != THREAD_LIMBO)
  573.     CallError(stacktop,
  574.           "thread-start: thread not in limbo",thread,NONCONTINUABLE);
  575.  
  576.   HOG_THREAD(thread);
  577.  
  578.   /* Place the args inside and wind her up... */
  579.  
  580.   thread_status(thread) = THREAD_READY;
  581.   thread->THREAD.args = args;
  582.  
  583.   RELEASE_THREAD(thread);
  584.  
  585.   /* Bung it on the ready queue... */
  586.  
  587.   STACK_TMP(thread);
  588.   system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  589.   UNSTACK_TMP(thread);
  590.   {
  591.     LispObject xx;
  592.     STACK_TMP(thread);
  593.     EUCALLSET_2(xx,Fn_cons,thread,nil);
  594.     UNSTACK_TMP(thread);
  595.     
  596.     thread->THREAD.thd_queue=xx;
  597.     EUCALLSET_2(xx,
  598.         Fn_nconc, SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  599.         thread->THREAD.thd_queue);
  600.     SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)=xx;
  601.   }
  602.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  603.  
  604.   /* All is cool... */
  605.  
  606.   /* Poke layabouts... */
  607.  
  608.   system_kick_sleepers();
  609.  
  610.   return(ARG_0(stackbase));
  611. }
  612. EUFUN_CLOSE
  613.  
  614. EUFUN_0( Fn_thread_reschedule)
  615. {
  616.   LispObject thread = CURRENT_THREAD();
  617.  
  618. #ifdef DGC
  619.   /* Tidy the stacks ... */
  620.   void tidy_stacks(LispObject *);
  621.   tidy_stacks(stacktop);
  622. #endif
  623.  
  624.   HOG_THREAD(thread);
  625.   if (SET_STATE(thread)) return(nil);
  626.   RELEASE_THREAD(thread);
  627.  
  628. #ifdef nope /* Mon Mar  2 12:54:29 1992 */
  629. /**/  /* following lines commented out --- probably wrong */
  630. /**/  system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  631. /**/  SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  632. /**/  = EUCALL_2(Fn_nconc,SYSTEM_GLOBAL_VALUE(list_ready_thread_queue), Fn_cons(thread,nil));
  633. /**/  system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  634. /**/  /**/
  635. #endif /* nope Mon Mar  2 12:54:29 1992 */
  636.  
  637.   /* Call the dispatcher... */
  638.  
  639.   thread_status(thread) = THREAD_READY;
  640.   RUN_DISPATCHER(thread);
  641.  
  642.   return(nil);
  643. }
  644. EUFUN_CLOSE
  645.  
  646. EUFUN_0( Fn_thread_suspend)
  647. {
  648.   LispObject thread = CURRENT_THREAD();
  649.  
  650. #ifdef DGC
  651.   /* Tidy the stacks ... */
  652.   void tidy_stacks(LispObject *);
  653.   tidy_stacks(stacktop);
  654. #endif
  655.  
  656.   /* Must be running */
  657.   STACK_TMP(thread);
  658.  
  659.   if (SET_STATE(thread))
  660.     {    
  661.       thread=ARG_0(stackbase);
  662.       return(thread->THREAD.args);
  663.     }
  664.  
  665.   thread_status(thread) = THREAD_LIMBO;
  666.  
  667.   RUN_DISPATCHER(nil);
  668.   
  669.   if (thread_signalled(thread))
  670.     return nil;
  671.   else
  672.     return lisptrue;
  673. }
  674. EUFUN_CLOSE
  675.  
  676. EUFUN_0( Fn_abort_thread)
  677. {
  678.   LispObject thread = CURRENT_THREAD();
  679.  
  680. #ifdef DGC
  681.   /* Tidy the stacks ... */
  682.   void tidy_stacks(LispObject *);
  683.   tidy_stacks(stacktop);
  684. #endif
  685.  
  686.   HOG_THREAD(thread);
  687.   thread_status(thread) = THREAD_ABORTED;
  688.   RELEASE_THREAD(thread);
  689.  
  690.   RUN_DISPATCHER(nil);
  691.  
  692.   return(nil);
  693. }
  694. EUFUN_CLOSE
  695.  
  696. EUFUN_1( Fn_thread_value, thread)
  697. {
  698.   int wret;
  699.   LispObject cons_hack;
  700.   if (!is_thread(thread))
  701.     CallError(stacktop,"thread-value: non-thread",thread,NONCONTINUABLE);
  702.  
  703.   while (!thread_signalled(CURRENT_THREAD()))
  704.     {
  705.       switch (thread_status(thread)) 
  706.     {
  707.     case THREAD_RETURNED:  
  708.       cons_hack=EUCALL_2(Fn_cons,lisptrue,thread->THREAD.value);
  709.       return cons_hack;
  710.     
  711.     case THREAD_LIMBO:
  712.     case THREAD_RUNNING:
  713.     case THREAD_READY: 
  714.       EUCALL_0(Fn_thread_reschedule);
  715.       thread=ARG_0(stackbase);
  716.       break;
  717.  
  718.     case THREAD_ABORTED: 
  719.       CallError(stacktop,
  720.             "thread_value: thread aborted",thread,NONCONTINUABLE);
  721.       break;
  722.  
  723.     default:
  724.       CallError(stacktop,
  725.             "thread-value: bad thread status",thread,NONCONTINUABLE);
  726.     }
  727.     }
  728.  
  729.   cons_hack=EUCALL_2(Fn_cons,nil,nil);
  730.   return cons_hack;
  731. }
  732. EUFUN_CLOSE
  733.  
  734. EUFUN_2(Fn_set_signalled,thread,value)
  735. {
  736.   thread_signalled(thread) = (value==lisptrue)? 1 : 0;
  737.   
  738.   return value;
  739. }
  740. EUFUN_CLOSE
  741.  
  742. static LispObject sym_limbo;
  743. static LispObject sym_ready;
  744. static LispObject sym_running;
  745. static LispObject sym_returned;
  746. static LispObject sym_aborted;
  747.  
  748. EUFUN_1( Fn_thread_state, th)
  749. {
  750.   if (!is_thread(th))
  751.     CallError(stacktop,"thread-state: non-thread",th,NONCONTINUABLE);
  752.  
  753.   switch (thread_status(th)) {
  754.  
  755.    case THREAD_LIMBO:    return(sym_limbo);
  756.    case THREAD_READY:    return(sym_ready);
  757.    case THREAD_RUNNING:  return(sym_running);
  758.    case THREAD_RETURNED: return(sym_returned);
  759.    case THREAD_ABORTED:  return(sym_aborted);
  760.  
  761.    default: CallError(stacktop,"thread-state: weird state",th,NONCONTINUABLE);
  762.  
  763.   }
  764.  
  765.   return(nil); /* Dummy */
  766. }
  767. EUFUN_CLOSE
  768.  
  769. EUFUN_0( Fn_thread_queue)
  770. {
  771.   return(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  772. }
  773. EUFUN_CLOSE
  774.  
  775. EUFUN_0( Fn_kick)
  776. {
  777.   system_kick_sleepers();
  778.   return(nil);
  779. }
  780. EUFUN_CLOSE
  781.  
  782. /* *************************************************************** */
  783. /*                        Allocation Methods                       */
  784. /* *************************************************************** */
  785.  
  786. static LispObject sym_stack_size;
  787.  
  788. EUFUN_2( Md_allocate_instance_Thread_Class, c, il)
  789. {
  790.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  791.   LispObject new,size;
  792.   int i;
  793.  
  794.   if ((size = search_keylist(stacktop,il,sym_stack_size)) == unbound)
  795.     size = SYSTEM_GLOBAL_VALUE(default_thread_stack_size);
  796.   else {
  797.     
  798.     if (!is_fixnum(size))
  799.       CallError(stacktop,"allocate-instance(thread): non-integer stack size",
  800.         size,NONCONTINUABLE);
  801.  
  802.     if (intval(size) < MIN_THREAD_STACK_SIZE)
  803.       CallError(stacktop,"allocate-instance(thread): stack size too small",
  804.         size,NONCONTINUABLE);
  805.  
  806.   }
  807.  
  808.   new = 
  809.     (LispObject) 
  810.       allocate_thread(stacktop,
  811.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  812.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size))
  813.                  / GC_STACK_RATIO,
  814.               intval(c->CLASS.local_count));
  815.  
  816.   lval_classof(new) = ARG_0(stackbase);
  817.  
  818.   return(new);
  819. }
  820. EUFUN_CLOSE
  821.  
  822. EUFUN_2( Fn_initialize_thread, t, il)
  823. {
  824.   extern LispObject Md_initialize_instance_1(LispObject*);
  825.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  826.   LispObject fun;
  827.  
  828.   if ((fun = search_keylist(stacktop,il,sym_function)) == unbound)
  829.     CallError(stacktop,"allocate-instance(thread): missing function value",
  830.           il,NONCONTINUABLE);
  831.  
  832.   t->THREAD.fun = fun;
  833.   thread_status(t) = THREAD_LIMBO;
  834.   
  835.   return t;
  836. }
  837. EUFUN_CLOSE
  838.  
  839. #endif
  840.  
  841. /* *************************************************************** */
  842. /* Test'n'debug                                                    */
  843. /* *************************************************************** */
  844.  
  845. #ifndef MACHINE_ANY
  846.  
  847. LispObject test_reschedule_runner(LispObject* stacktop)
  848. {
  849.   while (TRUE) (void) EUCALL_0(Fn_thread_reschedule);
  850.  
  851.   return(nil);
  852. }
  853.  
  854. EUFUN_1( Fn_test_reschedule, n)
  855. {
  856.   int cn;
  857.  
  858.   cn = intval(n);
  859.  
  860.   while (cn--) {
  861.     LispObject th;
  862.  
  863.     th = allocate_module_function(stacktop, NULL, NULL,
  864.                   test_reschedule_runner,0);
  865.     EUCALLSET_2(th, Fn_make_thread, th, nil);
  866.  
  867.     printf("Test: %x\n",(int) th); fflush(stdout);
  868.  
  869.     EUCALL_2(Fn_thread_start,th,nil);
  870.   }
  871.  
  872.   EUCALL_0(Fn_thread_suspend);
  873.  
  874.   return(nil);
  875. }
  876. EUFUN_CLOSE
  877.  
  878. EUFUN_0( Fn_test_gc)
  879. {
  880.   
  881.   while (1) garbage_collect(stacktop);
  882.  
  883.   return(nil);
  884. }
  885. EUFUN_CLOSE
  886.  
  887. #endif
  888.  
  889. /* so we know who we are... Note that this is an expensive function to call*/
  890. EUFUN_0(Fn_feel_arch)
  891. {
  892. #ifdef MACHINE_ANY
  893.   return(get_symbol(stacktop,"generic"));
  894. #elif defined(MACHINE_BSD)
  895.   return(get_symbol(stacktop,"BSD"));
  896. #elif MACHINE_SYSTEMV
  897.   return(get_symbol(stacktop,"System-V"));
  898. #else
  899.   return(get_symbol(stacktop,"something-strange"));
  900. #endif
  901. }
  902. EUFUN_CLOSE
  903. /* *************************************************************** */
  904. /* Initialisation of this section                                  */
  905. /* *************************************************************** */
  906.  
  907. #ifdef MACHINE_ANY
  908. #define THREADS_ENTRIES 7
  909. #else
  910. #define THREADS_ENTRIES 23
  911. #endif
  912.  
  913. #define SET_ASSOC(a,b) \
  914.   { LispObject tmp,tmp2; \
  915.     STACK_TMP(a); \
  916.     tmp2=b; \
  917.     UNSTACK_TMP(tmp); \
  918.     set_anon_associate(stacktop,tmp,tmp2); \
  919.   }
  920.  
  921. MODULE Module_threads;
  922. LispObject Module_threads_values[THREADS_ENTRIES];
  923.  
  924. void initialise_threads(LispObject *stacktop)
  925. {
  926.   Cb_signal_callback=EUCALL_2(Fn_cons,nil,nil);
  927.   add_root(&Cb_signal_callback);
  928.   open_module(stacktop,
  929.           &Module_threads,Module_threads_values,"threads",THREADS_ENTRIES);
  930.  
  931.   (void) make_module_function(stacktop,"threadp",Fn_threadp,1);
  932.   (void) make_module_function(stacktop,"set-sig-handler",Fn_set_sig_handler,1);
  933.   (void) make_module_function(stacktop,"current-thread",Fn_current_thread,0);
  934.   (void) make_module_function(stacktop,"continuationp",Fn_continuationp,1);
  935.  
  936.   (void) make_module_function(stacktop,"feel-machine-type",Fn_feel_arch,0);
  937.  
  938. #ifdef MACHINE_ANY
  939.   (void) make_module_entry(stacktop,"*threads-available*",nil);
  940. #else
  941.   (void) make_module_entry(stacktop,"*threads-available*",
  942.                allocate_integer(stacktop,RUNNING_PROCESSORS()));
  943. #endif
  944.  
  945. #ifndef MACHINE_ANY
  946.  
  947.   sym_stack_size = get_symbol(stacktop,"stack-size");
  948.   add_root(&sym_stack_size);
  949.   sym_limbo = get_symbol(stacktop,"limbo");
  950.   add_root(&sym_limbo);
  951.   sym_ready = get_symbol(stacktop,"ready");
  952.   add_root(&sym_ready);
  953.   sym_running = get_symbol(stacktop,"running");
  954.   add_root(&sym_running);
  955.   sym_returned = get_symbol(stacktop,"returned");
  956.   add_root(&sym_returned);
  957.   sym_aborted = get_symbol(stacktop,"aborted");
  958.   add_root(&sym_aborted);
  959.  
  960.   SYSTEM_INITIALISE_GLOBAL(LispObject,
  961.                default_thread_stack_size,
  962.                allocate_integer(stacktop,MY_THREAD_STACK_SIZE));
  963.   ADD_SYSTEM_GLOBAL_ROOT(default_thread_stack_size);
  964.  
  965.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_ready_thread_queue,nil);
  966.   ADD_SYSTEM_GLOBAL_ROOT(list_ready_thread_queue); 
  967.  
  968.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_dispatcher_function,nil);
  969.   ADD_SYSTEM_GLOBAL_ROOT(current_dispatcher_function);
  970.  
  971.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_dispatcher_threads,nil);
  972.   ADD_SYSTEM_GLOBAL_ROOT(list_dispatcher_threads);
  973.  
  974.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem,0);
  975.   system_allocate_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  976.  
  977. #if 0 /* Commented out 'cos initializing thread now at lisp level.. */
  978.   (void) make_module_function(stacktop,"make-thread",Fn_make_thread,-2);
  979. #endif
  980.   (void) make_module_function(stacktop,"thread-start",Fn_thread_start,-2);
  981.   (void) make_module_function(stacktop,"thread-set-signalled",Fn_set_signalled,2);
  982.   (void) make_module_function(stacktop,"internal-thread-reschedule",Fn_thread_reschedule,0);
  983.  
  984.   (void) make_module_function(stacktop,"internal-thread-value",Fn_thread_value,1);
  985.   (void) make_module_function(stacktop,"internal-thread-suspend",Fn_thread_suspend,0);
  986.   (void) make_module_function(stacktop,"generic_allocate_instance,Thread_Class",
  987.                   Md_allocate_instance_Thread_Class,2);
  988.   (void) make_module_function(stacktop,"initialize-thread", Fn_initialize_thread,2);
  989.   
  990.   SYSTEM_GLOBAL_VALUE(current_dispatcher_function)
  991.     = make_unexported_module_function(stacktop,"dispatcher",Fn_dispatch,0);
  992.  
  993.   (void) make_module_function(stacktop,"kick",Fn_kick,0);
  994.  
  995.   (void) make_module_function(stacktop,"not-thread-reset",Fn_thread_reset,1);
  996.  
  997.   (void) make_module_entry(stacktop,"*minimum-stack-size*",
  998.                allocate_integer(stacktop,MIN_THREAD_STACK_SIZE));
  999.  
  1000.   (void) make_module_function(stacktop,"thread-state",Fn_thread_state,1);
  1001.   (void) make_module_function(stacktop,"thread-queue",Fn_thread_queue,0);
  1002.  
  1003.   SET_ASSOC(make_module_function(stacktop,"default-thread-stack-size",
  1004.                  Fn_default_thread_stack_size,
  1005.                  0),
  1006.         make_module_function(stacktop,"(setter default-thread-stack-size)",
  1007.                  Fn_default_thread_stack_size_setter,
  1008.                  1));
  1009.        
  1010.   (void) make_module_function(stacktop,"test-reschedule",Fn_test_reschedule,1);
  1011.  
  1012.   (void) make_module_function(stacktop,"test-gc",Fn_test_gc,0);
  1013.  
  1014. #endif
  1015.  
  1016.   close_module();
  1017.  
  1018. }
  1019.  
  1020. #ifndef MACHINE_ANY
  1021.  
  1022. static SYSTEM_GLOBAL(int,start_register);
  1023.  
  1024. #define DISPATCHER_THREAD_STACK_SIZE (4*1048) /* Woz 4 */
  1025. #define DISPATCHER_THREAD_GC_STACK_SIZE (1024)
  1026.  
  1027. void runtime_begin_processes(LispObject* stacktop)
  1028. {
  1029.   extern void rig_gc_thread(LispObject *);
  1030.   extern int command_line_processors;
  1031.   int i;
  1032.  
  1033.   RUNNING_PROCESSORS() 
  1034.     = (command_line_processors == 0 ? 1 : command_line_processors);
  1035.  
  1036.   rig_gc_thread(stacktop);
  1037.  
  1038.   SYSTEM_INITIALISE_GLOBAL(int,start_register,0);
  1039.  
  1040.   for (i=0; i<RUNNING_PROCESSORS(); ++i) {
  1041.     int val;
  1042.     LispObject new_dt,tmp;
  1043.  
  1044.     /* Create and register dispatcher thread for each new process... */
  1045.  
  1046.     new_dt = allocate_thread(stacktop,
  1047.                  DISPATCHER_THREAD_STACK_SIZE,
  1048.                  DISPATCHER_THREAD_GC_STACK_SIZE,0);
  1049.  
  1050.     new_dt->THREAD.fun = SYSTEM_GLOBAL_VALUE(current_dispatcher_function);
  1051.  
  1052.     (void) system_thread_rig(stacktop,new_dt);
  1053.  
  1054.     EUCALLSET_2(tmp,
  1055.         Fn_cons,new_dt,SYSTEM_GLOBAL_VALUE(list_dispatcher_threads));
  1056.     SYSTEM_GLOBAL_VALUE(list_dispatcher_threads)=tmp;
  1057.     val = (i == 0 ? 0 : fork());
  1058.  
  1059.     if (val == -1) {
  1060.       fprintf(stderr,"\nRats: fork wimped out\n\n"); fflush(stderr);
  1061.       system_lisp_exit(-1);
  1062.     }
  1063.     if (val == 0) { /* New! */
  1064.       SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread) = new_dt;
  1065.       add_root(&local_dispatcher_thread);
  1066. #ifndef NODEBUG
  1067. /*      startdb();*/
  1068. #endif
  1069.       if (i != 0) {
  1070.     runtime_reset_allocator(stacktop);
  1071.  
  1072.     break;
  1073.       }
  1074.  
  1075.     }
  1076.  
  1077.     ++SYSTEM_GLOBAL_VALUE(start_register);
  1078.  
  1079.   }
  1080.  
  1081.   system_register_process(i-1);
  1082.   SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number) = i-1;
  1083.  
  1084.   /* Wait for it... wait for it... */
  1085.  
  1086.   while (SYSTEM_GLOBAL_VALUE(start_register) != RUNNING_PROCESSORS());
  1087.   
  1088.   ON_collect();
  1089.  
  1090.   RUN_DISPATCHER(nil);
  1091. }
  1092.  
  1093. #endif
  1094.  
  1095.